home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xscheme.arc / xssym.c < prev   
C/C++ Source or Header  |  1989-01-29  |  2KB  |  88 lines
  1. /* xssym.c - symbol handling routines */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* external variables */
  9. extern LVAL obarray;
  10.  
  11. /* forward declarations */
  12. LVAL findprop();
  13.  
  14. /* xlsubr - define a builtin function */
  15. xlsubr(sname,type,fcn,offset)
  16.   char *sname; int type; LVAL (*fcn)(); int offset;
  17. {
  18.     LVAL sym;
  19.     sym = xlenter(sname);
  20.     setvalue(sym,cvsubr(type,fcn,offset));
  21. }
  22.  
  23. /* xlenter - enter a symbol into the obarray */
  24. LVAL xlenter(name)
  25.   char *name;
  26. {
  27.     LVAL array,sym;
  28.     int i;
  29.  
  30.     /* get the current obarray and the hash index for this symbol */
  31.     array = getvalue(obarray);
  32.     i = hash(name,HSIZE);
  33.  
  34.     /* check if symbol is already in table */
  35.     for (sym = getelement(array,i); sym; sym = cdr(sym))
  36.     if (strcmp(name,getstring(getpname(car(sym)))) == 0)
  37.         return (car(sym));
  38.  
  39.     /* make a new symbol node and link it into the list */
  40.     sym = cons(cvsymbol(name),getelement(array,i));
  41.     setelement(array,i,sym);
  42.     sym = car(sym);
  43.  
  44.     /* return the new symbol */
  45.     return (sym);
  46. }
  47.  
  48. /* xlgetprop - get the value of a property */
  49. LVAL xlgetprop(sym,prp)
  50.   LVAL sym,prp;
  51. {
  52.     LVAL p;
  53.     return ((p = findprop(sym,prp)) ? car(p) : NIL);
  54. }
  55.  
  56. /* xlputprop - put a property value onto the property list */
  57. xlputprop(sym,val,prp)
  58.   LVAL sym,val,prp;
  59. {
  60.     LVAL pair;
  61.     if (pair = findprop(sym,prp))
  62.     rplaca(pair,val);
  63.     else
  64.     setplist(sym,cons(prp,cons(val,getplist(sym))));
  65. }
  66.  
  67. /* findprop - find a property pair */
  68. LOCAL LVAL findprop(sym,prp)
  69.   LVAL sym,prp;
  70. {
  71.     LVAL p;
  72.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
  73.     if (car(p) == prp)
  74.         return (cdr(p));
  75.     return (NIL);
  76. }
  77.  
  78. /* hash - hash a symbol name string */
  79. int hash(str,len)
  80.   char *str;
  81. {
  82.     int i;
  83.     for (i = 0; *str; )
  84.     i = (i << 2) ^ *str++;
  85.     i %= len;
  86.     return (i < 0 ? -i : i);
  87. }
  88.